home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / xlisp16.arc / XLSYS.C < prev   
Text File  |  1985-10-06  |  4KB  |  163 lines
  1. /* xlsys.c - xlisp builtin system functions */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern NODE ***xlstack,*xlenv;
  10. extern int anodes;
  11.  
  12. /* external symbols */
  13. extern NODE *a_subr,*a_fsubr;
  14. extern NODE *a_list,*a_sym,*a_int,*a_float,*a_str,*a_obj,*a_fptr,*a_vect;
  15. extern NODE *true;
  16.  
  17. /* xload - direct input from a file */
  18. NODE *xload(args)
  19.   NODE *args;
  20. {
  21.     NODE ***oldstk,*fname,*val;
  22.     int vflag,pflag;
  23.     char *name;
  24.  
  25.     /* create a new stack frame */
  26.     oldstk = xlsave(&fname,NULL);
  27.  
  28.     /* get the file name, verbose flag and print flag */
  29.     fname = xlarg(&args);
  30.     vflag = (args ? xlarg(&args) != NIL : TRUE);
  31.     pflag = (args ? xlarg(&args) != NIL : FALSE);
  32.     xllastarg(args);
  33.  
  34.     /* get the filename string */
  35.     if (symbolp(fname))
  36.     name = getstring(getpname(fname));
  37.     else if (stringp(fname))
  38.     name = getstring(fname);
  39.     else
  40.     xlfail("bad argument type",fname);
  41.  
  42.     /* load the file */
  43.     val = (xlload(name,vflag,pflag) ? true : NIL);
  44.  
  45.     /* restore the previous stack frame */
  46.     xlstack = oldstk;
  47.  
  48.     /* return the status */
  49.     return (val);
  50. }
  51.  
  52. /* xgc - xlisp function to force garbage collection */
  53. NODE *xgc(args)
  54.   NODE *args;
  55. {
  56.     /* make sure there aren't any arguments */
  57.     xllastarg(args);
  58.  
  59.     /* garbage collect */
  60.     gc();
  61.  
  62.     /* return nil */
  63.     return (NIL);
  64. }
  65.  
  66. /* xexpand - xlisp function to force memory expansion */
  67. NODE *xexpand(args)
  68.   NODE *args;
  69. {
  70.     int n,i;
  71.  
  72.     /* get the new number to allocate */
  73.     n = (args ? getfixnum(xlmatch(INT,&args)) : 1);
  74.     xllastarg(args);
  75.  
  76.     /* allocate more segments */
  77.     for (i = 0; i < n; i++)
  78.     if (!addseg())
  79.         break;
  80.  
  81.     /* return the number of segments added */
  82.     return (cvfixnum((FIXNUM)i));
  83. }
  84.  
  85. /* xalloc - xlisp function to set the number of nodes to allocate */
  86. NODE *xalloc(args)
  87.   NODE *args;
  88. {
  89.     int n,oldn;
  90.  
  91.     /* get the new number to allocate */
  92.     n = getfixnum(xlmatch(INT,&args));
  93.  
  94.     /* make sure there aren't any more arguments */
  95.     xllastarg(args);
  96.  
  97.     /* set the new number of nodes to allocate */
  98.     oldn = anodes;
  99.     anodes = n;
  100.  
  101.     /* return the old number */
  102.     return (cvfixnum((FIXNUM)oldn));
  103. }
  104.  
  105. /* xmem - xlisp function to print memory statistics */
  106. NODE *xmem(args)
  107.   NODE *args;
  108. {
  109.     /* make sure there aren't any arguments */
  110.     xllastarg(args);
  111.  
  112.     /* print the statistics */
  113.     stats();
  114.  
  115.     /* return nil */
  116.     return (NIL);
  117. }
  118.  
  119. /* xtype - return type of a thing */
  120. NODE *xtype(args)
  121.     NODE *args;
  122. {
  123.     NODE *arg;
  124.  
  125.     if (!(arg = xlarg(&args)))
  126.     return (NIL);
  127.  
  128.     switch (ntype(arg)) {
  129.     case SUBR:    return (a_subr);
  130.     case FSUBR:    return (a_fsubr);
  131.     case LIST:    return (a_list);
  132.     case SYM:    return (a_sym);
  133.     case INT:    return (a_int);
  134.     case FLOAT:    return (a_float);
  135.     case STR:    return (a_str);
  136.     case OBJ:    return (a_obj);
  137.     case FPTR:    return (a_fptr);
  138.     case VECT:    return (a_vect);
  139.     default:    xlfail("bad node type");
  140.     }
  141. }
  142.  
  143. /* xbaktrace - print the trace back stack */
  144. NODE *xbaktrace(args)
  145.   NODE *args;
  146. {
  147.     int n;
  148.  
  149.     n = (args ? getfixnum(xlmatch(INT,&args)) : -1);
  150.     xllastarg(args);
  151.     xlbaktrace(n);
  152.     return (NIL);
  153. }
  154.  
  155. /* xexit - get out of xlisp */
  156. NODE *xexit(args)
  157.   NODE *args;
  158. {
  159.     xllastarg(args);
  160.     exit();
  161. }
  162. 
  163.